Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/ansi_130.zip/MUSICA.PAS

Pascal/Delphi Source File | 1990-06-03 | 14KB | 483 lines

{ $A+,B-,D-,E-,F+,I-,L-,O+,R-,S-,V-}
(*
    Musica v1.00 (c) CopyRight P.H.Rankin Hansen 1990.

    This unit implements the Play  statement knovn from Basic in Turbo
    Pascal  versions  5.x  and  higher.  (version  4  does not support
    procedural types). The syntax adhers  to the Basic syntax with the
    exception  of the  X command,  wich has  no meaning  in a compiled
    language.

    Released in Denmark on June 3rd, 1990 as part of PingAnsi 1.30.

    By  using this  material You  assume FULL  responsibility for  ANY
    consequences - direct or indirect - thereof. Any dispute regarding
    this  material shall  be setteled  by Danish  law and  in a Danish
    Court.

     (Sigh!)

    This source  may NOT be  used by Lawyers,  Politicians or, persons
    engaged  in any  other form  of terrorism.  Otherwise the usage is
    free.

    This  source  may  be  freely  distributed  as  long  as no fee is
    charged.

    Please direct any comments, corrections, modifications via netmail
    to:

                      Ping Hansen - Fido Net 2:231/62.58

*)
Unit Musica;

Interface

Uses Dos, TpCrt;{CRT will do as well}

Const
  MaxPlayBuffer       = 64;
  { set this to true to disable background processing of sound }
  NoBackground        : Boolean = False;
  { If this is set stuff will WAIT for room in play buffer before returning }
  WaitForSpace        : Boolean = True;

Var
  BackGroundPlayHook  : Procedure(Tone, Duration : Word);
  PlayBuffer          : Array[0..MaxPlayBuffer] Of
    Record
      Tone,
      Duration            : Word;
    End;

Procedure Play(St : String);
Procedure PurgePlayBuffer;
Function PlayBufferEmpty : Boolean;
Function PlayBufferFull : Boolean;
  {$F+}
Procedure Stuff(Tone, Time : Word);
  {$F-}
Function GrabTimer  : Boolean;
  {$F+}
Procedure ReleaseTimer;
  {$F-}

  {-----------------------------------------------------------------------}

Implementation

Const
  Timer0              = 0;
  FirstPlay           : Word = 0; { buffer Pointer }
  LastPlay            : Word = 1; { buffer Pointer }
  TimerMode           : Byte = 0; { saved mode for the timer }

Var
  SaveExitProc        : Pointer;
  SaveTimerInt        : Pointer;

  {-----------------------------------------------------------------------}

  Procedure Play(St : String);

  Const
    Notes               : Array[1..84] Of Word =
    { C    C#,D-  D    D#,E-  E     F    F#,G-  G    G#,A-  A    A#,B-  B  }
    (0065, 0070, 0073, 0078, 0082, 0087, 0093, 0098, 0104, 0110, 0117, 0123,
     0131, 0139, 0147, 0156, 0165, 0175, 0185, 0196, 0208, 0220, 0233, 0247,
     0262, 0277, 0294, 0311, 0330, 0349, 0370, 0392, 0415, 0440, 0466, 0494,
     0523, 0554, 0587, 0622, 0659, 0698, 0740, 0784, 0831, 0880, 0932, 0987,
     1047, 1109, 1175, 1245, 1329, 1397, 1480, 1568, 1661, 1760, 1865, 1976,
     2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
     4186, 4435, 4699, 4978, 5274, 5588, 5920, 6272, 6645, 7040, 7459, 7902);
    MusicType           : Byte = 7; {Normal - note plays for 7/8 of time}
    Tempo               : Word = 120; {120 beats per minute}
    StdNoteLength       : Word = 4; {Quarter note}
    Octave              : Word = 3; {Third octave}
    BackGround          : Boolean = False; {Mn is default}

  Var
    PlayTime, IdleTime,
    DotTime, TempTime,
    NoteLength, Note,
    Index               : Word;
    Ch                  : Char;

    {-------------}

    Function Numerical(Var Index : Word) : Word;

    Var
      n                   : Word;
    Begin
      n := 0;
      While (Index <= Length(St)) And (St[Index] In ['0'..'9']) Do
      Begin
        n := n * 10 + Ord(St[Index]) - Ord('0');
        Inc(Index)
      End;
      Numerical := n;
    End {Numerical} ;

    {-------------}

    Procedure CheckDots(Var Index : Word);

    Begin
      While (Index <= Length(St)) And ((St[Index] = '.') Or (St[Index] = ',')) Do
      Begin
        DotTime := DotTime + DotTime Div 2;
        Inc(Index)
      End;
    End {CheckDots} ;

    {-------------}

  Begin                           {Play subroutine}
    Index := 1;
    While Index < Length(St) Do
    Begin
      NoteLength := StdNoteLength;
      DotTime := 1000;
      Ch := Upcase(St[Index]);
      Case Ch Of
        'A'..'G' :
          Begin                   {read note}
            Note := Pos(Ch, 'CcDdEFfGgAaB');
            Inc(Index);

            {Check for sharp or flat}
            If Index <= Length(St) Then
              Case St[Index] Of
                '#', '+' :
                  Begin
                    Inc(Note);
                    Inc(Index);
                  End;
                '-' :
                  Begin
                    Dec(Note);
                    Inc(Index);
                  End;
              End;

            {Check for length suffix}
            If (Index <= Length(St)) And
            (St[Index] In ['0'..'9']) Then
            Begin
              NoteLength := Numerical(Index);
            End;
            CheckDots(Index);

            {calculate periods}
            TempTime := Round(DotTime / Tempo / NoteLength * 240);
            PlayTime := Round(TempTime * MusicType / 8);
            IdleTime := TempTime - PlayTime;

            {Play the note}
            If BackGround
            Then
            Begin
              BackGroundPlayHook(Notes[Note + Octave * 12], PlayTime);
              If IdleTime <> 0 Then BackGroundPlayHook(0, IdleTime);
            End
            Else
            Begin
              Sound(Notes[Note + Octave * 12]);
              Delay(PlayTime);
              If IdleTime <> 0 Then
              Begin
                NoSound;
                Delay(IdleTime)
              End;
            End;
            {}
            {Check for ^C or Ctl-Break}
            If keypressed And (ReadKey = ^C) Then
            Begin
              NoSound;
              Exit;
            End;
            {}
          End;
        '<' :
          Begin                   {step octave down}
            If Octave > 0 Then Dec(Octave);
            Inc(Index);
          End;
        '>' :
          Begin                   {step octave up}
            If Octave < 6 Then Inc(Octave);
            Inc(Index);
          End;
        'L' :
          Begin                   {set notelength}
            Inc(Index);
            StdNoteLength := Numerical(Index);
            If (StdNoteLength < 1) Or (StdNoteLength > 64) Then
              StdNoteLength := 4;
          End;
        'M' :
          Begin                   {determine music type}
            Inc(Index);
            If (Index <= Length(St)) Then
            Begin
              Case Upcase(St[Index]) Of
                'S' : MusicType := 6; {music staccato}
                'N' : MusicType := 7; {music normal}
                'L' : MusicType := 8; {music legato}
                'B' : BackGround := True; {enable background buffering}
                'F' : BackGround := False; {disable do.}
              End;
              Inc(Index);
            End;
          End;
        'O' :
          Begin                   {set octave}
            Inc(Index);
            Octave := Numerical(Index);
            If Octave > 6 Then Octave := 6;
          End;
        'P' :
          Begin                   {pause}
            NoSound;
            Inc(Index);
            NoteLength := Numerical(Index);
            If (NoteLength < 1) Or (NoteLength > 64) Then
              NoteLength := StdNoteLength;
            CheckDots(Index);

            {calculate pause}
            IdleTime := DotTime Div Tempo * (240 Div NoteLength);

            {execute pause}
            If BackGround
            Then BackGroundPlayHook(0, IdleTime)
            Else Delay(IdleTime);
          End;
        'T' :
          Begin                   {set tempo}
            Inc(Index);
            Tempo := Numerical(Index);
            If (Tempo < 32) Or (Tempo > 255) Then
              Tempo := 120;
          End;
        'N' :
          Begin                   {play note #nn}
            Inc(Index);
            Note := Numerical(Index);
            If (Note < 1) Then Note := 1;
            If (Note > 84) Then Note := 84;
            CheckDots(Index);

            {calculate periods}
            TempTime := Round(DotTime / Tempo / NoteLength * 240);
            PlayTime := Round(TempTime * MusicType / 8);
            IdleTime := TempTime - PlayTime;

            {Play the note}
            If BackGround
            Then
            Begin
              BackGroundPlayHook(Notes[Note + Octave * 12], PlayTime);
              If IdleTime <> 0 Then BackGroundPlayHook(0, IdleTime);
            End
            Else
            Begin
              Sound(Notes[Note + Octave * 12]);
              Delay(PlayTime);
              If IdleTime <> 0 Then
              Begin
                NoSound;
                Delay(IdleTime)
              End;
            End;
          End;
        Else                      {garbage collector}
          Inc(Index);             {pollution, Just dump it}
      End;
    End {While} ;
    NoSound;                      {we are finished}
  End {Play} ;

  {-----------------------------------------------------------------------}

  {$F+}
  Procedure DummyStuff(Tone, Duration : Word);
    {$F-}
    {dummy background}
  Begin
    If Tone <> 0
    Then Sound(Tone)
    Else NoSound;
    Delay(Duration);
  End {DummyStuff} ;

  {-------------------------------------------------------------------------}

  Procedure PurgePlayBuffer;

  Begin
    Inline($FA); {CLI}
    FillChar(PlayBuffer, SizeOf(PlayBuffer), 0);
    FirstPlay := 0;
    LastPlay := 1;
    Inline($FB); {STI}
  end {PurgePlayBuffer} ;

  {-------------------------------------------------------------------------}

  Function PlayBufferEmpty : Boolean;

  Begin
    PlayBufferEmpty := (FirstPlay = LastPlay);
  End {PlayBufferEmpty} ;

  {-------------------------------------------------------------------------}

  Function PlayBufferFull : Boolean;

  Begin
    PlayBufferFull := (LastPlay = FirstPlay - 1) Or
    ((LastPlay = MaxPlayBuffer) And (FirstPlay = 1));
  End {PlayBufferFull} ;

  {-------------------------------------------------------------------------}

  {$F+}
  Procedure Stuff(Tone, Time : Word);
    {$F-}

    { Place a note in background buffer. }

  Begin
    If NoBackground Then
    Begin
      If Tone <> 0 Then Sound(Tone);
      Delay(Time);
      Exit;
    End;
    While WaitForSpace And PlayBufferFull Do {} ;
    If                            {(LastPlay <> FirstPlay - 1) And
    ((LastPlay <> MaxPlayBuffer) Or (FirstPlay <> 1))} Not PlayBufferFull Then
    Begin
      PlayBuffer[LastPlay].Tone := Tone;
      PlayBuffer[LastPlay].Duration := Time;
      Inc(LastPlay);
      If LastPlay > MaxPlayBuffer Then LastPlay := 1;
    End;
  End {Stuff} ;

  {-------------------------------------------------------------------------}

  Procedure InitTimer(Timer, Mode : Byte; Count : Word);

  Var
    Tics                : LongInt Absolute $40 : $6C;
    t                   : LongInt;

  Begin
    t := Tics;
    While t = Tics Do {} ;        { wait for clock tick }
    Inline($FA);                  {CLI}
    Port[$43] := Mode;
    Port[$40 + Timer] := Lo(Count);
    Port[$40 + Timer] := Hi(Count);
    Inline($FB);                  {STI}
  End;

  {-------------------------------------------------------------------------}

  Procedure NewTimer(BP : Word); Interrupt;

  Const
    InTune              : Boolean = True;
    TimerVar            : Word = 54; { no delay first time }
    Count               : Word = 05;
  Begin
    Inc(TimerVar);
    If TimerVar >= 55 Then
    Begin
      TimerVar := 0;
      Inline($9C / $FF / $1E / SaveTimerInt); { Pushf/Call Far SaveTimer }
    End
    Else
    Begin
      Port[$20] := $20;           { Non speciffic EOI }
    End;
    Inline($FB);                  {STI}
    If Count > 0 Then Dec(Count);
    If Count = 0 Then
    Begin
      If InTune Then
      Begin
        InTune := False;
        NoSound;
      End;
      If (LastPlay <> FirstPlay) Then
      Begin
        If (PlayBuffer[FirstPlay].Tone <> 0) Then
        Begin
          Sound(PlayBuffer[FirstPlay].Tone);
          InTune := True;
        End;
        If (PlayBuffer[FirstPlay].Duration <> 0)
        Then Count := PlayBuffer[FirstPlay].Duration;
        Inc(FirstPlay);
        If FirstPlay > MaxPlayBuffer Then FirstPlay := 1;
      End;
    End;
  End {NewTimer} ;

  {-------------------------------------------------------------------------}

  {$F+}
  Procedure ReleaseTimer;
    {$F-}

    { unload the interrupt handler }

  Begin
    { Reprogram the 8253 to a 55 ms period }
    InitTimer(Timer0, $36, 0);
    SetIntVec($8, SaveTimerInt);
    ExitProc := SaveExitProc;
    NoSound;
    BackgroundPlayHook := DummyStuff;
  End {ReleaseTimer} ;

  {-------------------------------------------------------------------------}

  Function GrabTimer  : Boolean;

  Begin
    GrabTimer := True;
    FillChar(PlayBuffer, SizeOf(PlayBuffer), 0);
    GetIntVec($8, SaveTimerInt);
(*
  Port[$43] := $E2;        { readback command. Timer 0, status. }
  TimerMode := Port[$40] And $0F + $30;
  if (TimerMode <> $36)
  then GrabTimer := False
  else
*)
    Begin
      SaveExitProc := ExitProc;
      InitTimer(Timer0, $36, $04A8);
      SetIntVec($8, @NewTimer);
      SaveExitProc := ExitProc;
      ExitProc := @ReleaseTimer;
      BackgroundPlayHook := Stuff;
    (*
    Stuff(10, 100); {void attempt to fix problem with first note}
    *)
    End;
  End {GrabTimer} ;

  {-----------------------------------------------------------------------}

Begin
  BackGroundPlayHook := DummyStuff;
End.